home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
PSPPD100
/
DBASE.PAS
next >
Wrap
Pascal/Delphi Source File
|
1992-09-18
|
27KB
|
1,258 lines
{
╔══════════════════╗
║ Pure Power ║
║ Database Ctrl. ║
║ Rev. 1.00 ║
╚══════════════════╝
}
{$F-} {$O-} {$A+} {$G-} {$I-}
{$V-} {$B-} {$X-} {$N+} {$E+}
{$I FINAL.PAS}
{$IFDEF FINAL}
{$R-} {$S-}
{$D-} {$L-}
{$ENDIF}
Unit DBase;
Interface
Uses Dos,Strings,DBStack;
Const
TempFile = '$$PPDB$$.$$$';
Signature = 'PPDATABASE';
CurVerHi = 1;
CurVerLo = 00;
NameFlag = 1;
InEXEFlag = 2;
DirFlag = 1;
C_None = 0;
C_ARJ = 1;
C_ZIP = 2;
C_LHA = 3;
C_ZOO = 4;
C_Other = 49;
Type
DBaseDirPtr = ^DBaseDir;
DBaseDir = Record
Name :String[12];
Number :Word;
Offset :LongInt;
Size :Word;
Attr :Byte;
Next :DBaseDirPtr;
End;
DBaseMain = Record
Total :Word;
Root :Pointer;
Data :DBaseDirPtr;
End;
DBaseFile = Object
PrevDirs :StackObject;
HaveNames,
InEXE :Boolean;
DataSize :Word;
Compress,
DirEntry :Byte; {Length of each Dir entry in bytes}
FileName :PathStr;
FileStart,
FileEnd :LongInt;
Dir :DBaseMain;
VerHi,
VerLo :Byte;
Procedure Init;
Procedure GotoDir (Number:Word);
Procedure DelDir (Number:Word);
Procedure AppendDir (Var Data:DBaseDir);
Procedure AdjustDirsAfter (Offset,BySize:LongInt);
Procedure AdjustStackAfter (Offset,BySize:LongInt);
Procedure DestroyDirs;
Function FindEXESignature (LookFrom:LongInt;Var EndPtr:LongInt):Word;
Function WriteHeader :Word;
Function FindDir (Var Data:DBaseDir):Word;
Function SetDirFlag (Name:String;Number:Word;Flag:Boolean):Word;
Function AddCompression (FName:PathStr;Method:Byte):Word;
Function CreateDatabase (FName:PathStr;NameOpt:Boolean):Word;
Function OpenDatabase (FName:PathStr;DStart,DEnd:LongInt):Word;
Function CloseDatabase :Word;
Function CrossIntoDatabase (Name:String;Number:Word):Word;
Function CrossOutOfDatabase:Word;
Function BlockInsert (Offset:LongInt;Data:Pointer;Size:Word):Word;
Function BlockOverwrite (Offset:LongInt;Data:Pointer;Size:Word):Word;
Function BlockDelete (Offset:LongInt; Size:Word):Word;
Function ReadDir :Word;
Function WriteDir :Word;
Function NewData (Name:String;Number:Word;Data:Pointer;Size:Word):Word;
Function ModData (Name:String;Number:Word;Data:Pointer):Word;
Function GetData (Name:String;Number:Word;Data:Pointer):Word;
Function DelData (Name:String;Number:Word):Word;
Function NewDataFile (Name:String;Number:Word;FName:String):Word;
Function ModDataFile (Name:String;Number:Word;FName:String):Word;
Function GetDataFile (Name:String;Number:Word;FName:String):Word;
Function ModEXE (Offset:LongInt;Data:Pointer;Size:Word):Word;
Function GetEXE (Offset:LongInt;Data:Pointer;Size:Word):Word;
Private
F :File;
End;
Function DatabaseErrorMsg(ErrorNumber:Word):String;
Implementation
Procedure DBaseFile.Init;
Begin
Dir.Total:=0;
Dir.Root :=NIL;
Dir.Data :=NIL;
FileStart:=0;
FileEnd :=0;
DirEntry :=0;
DataSize :=0;
FileName :='';
VerHi :=CurVerHi;
VerLo :=CurVerLo;
PrevDirs.Init;
End;
Procedure DBaseFile.GotoDir(Number:Word);
Var
T:Word;
Begin
If Dir.Root=NIL Then Exit;
T:=1;
Dir.Data:=Dir.Root;
While (T<Number) And (Dir.Data^.Next<>NIL) do
Begin
Dir.Data:=Dir.Data^.Next;
Inc(T);
End;
End;
Procedure DBaseFile.DelDir(Number:Word);
Var
P:DBaseDirPtr;
Q:Pointer;
Begin
Dec(Dir.Total);
If Number=1 Then
Begin
GotoDir(1);
P:=Dir.Data;
Dir.Root:=P^.Next;
Dir.Data:=P^.Next;
Dispose(P);
End
Else
Begin
GotoDir(Number);
Q:=Dir.Data^.Next;
P:=Dir.Data;
GotoDir(Number-1);
Dispose(P);
Dir.Data^.Next:=Q;
End;
End;
Procedure DBaseFile.AppendDir(Var Data:DBaseDir);
Var
Q :DBaseDirPtr;
Begin
New(Q);
Q^:=Data;
Q^.Next:=NIL;
Inc(Dir.Total);
If Dir.Total=1 Then
Begin
Dir.Root:=Q;
Dir.Data:=Q;
End
Else
Begin
GotoDir(65535);
Dir.Data^.Next:=Q;
End;
End;
Procedure DBaseFile.AdjustDirsAfter(Offset,BySize:LongInt);
Begin
Dir.Data:=Dir.Root;
While Dir.Data<>NIL do
Begin
If Dir.Data^.Offset>=Offset Then
Inc(Dir.Data^.Offset,BySize);
Dir.Data:=Dir.Data^.Next;
End;
End;
Procedure DBaseFile.AdjustStackAfter(Offset,BySize:LongInt);
Const
LastOffset:LongInt = 0;
Var
OldStack :StackObject;
DirInfo :Data;
Begin
If Offset<>MaxLongInt Then {Are we given an offset?}
LastOffset:=Offset {Yes, so use it and remember it}
Else
Offset:=LastOffset; {No, so use the last one we were given}
OldStack.Init;
While Not PrevDirs.Empty do
Begin
PrevDirs.Pop(DirInfo);
If DirInfo.FileStart>=Offset Then Inc(DirInfo.FileStart,BySize);
If DirInfo.FileEnd >=Offset Then Inc(DirInfo.FileEnd ,BySize);
OldStack.Push(DirInfo);
End;
While Not OldStack.Empty do
Begin
OldStack.Pop(DirInfo);
PrevDirs.Push(DirInfo);
End;
End;
Procedure DBaseFile.DestroyDirs;
Begin
Dir.Data:=Dir.Root;
While Dir.Data<>NIL do
Begin
Dir.Root:=Dir.Data^.Next;
Dispose(Dir.Data);
Dir.Data:=Dir.Root;
End;
Dir.Total:=0;
End;
Function DBaseFile.FindEXESignature(LookFrom:LongInt;Var EndPtr:LongInt):Word;
Const
MaxAm = 255;
Var
CheckSig:String;
NewSig :String[15];
Found :LongInt;
Amount :LongInt;
ThisTime:LongInt;
Begin
NewSig:=Signature+'EX';
Found :=0;
Amount:=FileSize(F)-LookFrom;
PadVar('',CheckSig,255);
NewSig:=NewSig+'E';
Seek(F,LookFrom);
While (Amount<>0) And (Found=0) do
Begin
If Amount>MaxAm Then
ThisTime:=MaxAm
Else
ThisTime:=Amount;
BlockRead(F,CheckSig[1],ThisTime);
If Pos(NewSig,CheckSig)>0 Then
Found:=FilePos(F)-ThisTime+Pos(NewSig,CheckSig)+Length(NewSig)-4
Else
Begin
If EOF(F) Then
Amount:=0
Else
Begin
Dec(Amount,ThisTime-18);
Seek(F,FilePos(F)-18);
End;
End;
End;
EndPtr:=Found;
FindEXESignature:=IOResult;
End;
Function DBaseFile.WriteHeader:Word;
Var
Hdr :String;
Begin
If InEXE Then
Move(DataSize,Hdr[1],2)
Else
Move(Dir.Total,Hdr[1],2);
Hdr[3]:=#0;
Hdr[4]:=Chr(Compress);
Hdr[5]:=Chr(0);
If InEXE Then
Hdr[5]:=Chr(Ord(Hdr[4]) Or InEXEFlag);
If HaveNames Then
Hdr[5]:=Chr(Ord(Hdr[4]) Or NameFlag);
Hdr[0]:=#5;
Hdr:=Hdr+Chr(CurVerHi)+Chr(CurVerLo)+Signature;
BlockWrite(F,Hdr[1],17);
WriteHeader:=IOResult;
End;
Function DBaseFile.SetDirFlag(Name:String;Number:Word;Flag:Boolean):Word;
Var
WhichOne :Word;
DirData :DBaseDir;
Begin
DirData.Name :=Name;
DirData.Number :=Number;
WhichOne:=FindDir(DirData);
If WhichOne<>0 Then
Begin
If Flag Then
Dir.Data^.Attr:=Dir.Data^.Attr Or DirFlag
Else
Dir.Data^.Attr:=Dir.Data^.Attr And (Not DirFlag);
SetDirFlag:=WriteDir;
End
Else
SetDirFlag:=603;
End;
Function DBaseFile.AddCompression(FName:PathStr;Method:Byte):Word;
Label
EndProc;
Var
ErrorCode:Word;
Begin
Assign(F,FName);
Reset(F,1);
ErrorCode:=IOResult;
If ErrorCode>0 Then Goto EndProc;
InEXE :=False;
HaveNames :=False;
Dir.Total :=0;
Compress :=Method;
Seek(F,FileSize(F));
ErrorCode:=WriteHeader;
Close(F);
EndProc:
AddCompression:=ErrorCode;
End;
Function DBaseFile.CreateDatabase(FName:PathStr;NameOpt:Boolean):Word;
{No Database may be open. The Database is NOT opened.}
Var
ErrorCode :Word;
Begin
Init;
InEXE :=False;
HaveNames :=NameOpt;
FileName :=FName;
Compress :=0;
Assign(F,FName);
Rewrite(F,1);
ErrorCode:=IOResult;
If ErrorCode=0 Then ErrorCode:=WriteHeader;
Close(F);
Init;
CreateDatabase:=ErrorCode;
End;
Function DBaseFile.FindDir(Var Data:DBaseDir):Word;
{Returns the position number in the list, not the file number}
Var
Found:Boolean;
Count:Word;
Begin
FindDir:=0;
If Dir.Total=0 Then Exit;
Found:=False;
If HaveNames Then
Begin
Count:=0;
Dir.Data:=Dir.Root;
While (Dir.Data<>NIL) And Not Found do
Begin
Inc(Count);
If (Data.Name=Dir.Data^.Name) And (Data.Number=Dir.Data^.Number) Then
Found:=True
Else
Dir.Data:=Dir.Data^.Next;
End;
If Not Found Then
Begin
Count:=0;
Dir.Data:=Dir.Root;
While (Dir.Data<>NIL) And Not Found do
Begin
Inc(Count);
If (Data.Name=Dir.Data^.Name) Then
Found:=True
Else
Dir.Data:=Dir.Data^.Next;
End;
End;
End;
If Not Found Then
Begin
Count:=0;
Dir.Data:=Dir.Root;
While (Dir.Data<>NIL) And Not Found do
Begin
Inc(Count);
If (Data.Number=Dir.Data^.Number) Then
Found:=True
Else
Dir.Data:=Dir.Data^.Next;
End;
End;
If Found Then
Begin
Data.Offset:=Dir.Data^.Offset;
Data.Size :=Dir.Data^.Size;
Data.Attr :=Dir.Data^.Attr;
FindDir :=Count;
End;
End;
Function DBaseFile.OpenDatabase(FName:PathStr;DStart,DEnd:LongInt):Word;
Label
EndProc,
EndProcAndClose;
Var
ErrorCode :Word;
CheckSig :String[10];
Begin
ErrorCode:=0;
If FName<>'' Then
Begin
Assign(F,FName);
Reset(F,1);
ErrorCode:=IOResult;
If ErrorCode<>0 Then Goto EndProc;
FileName:=FName;
End;
If (DStart=DEnd) Then { ** For InEXE Only ** }
Begin
ErrorCode:=FindEXESignature(DEnd,FileEnd);
End
Else
Begin
FileStart:=DStart;
If DEnd=MaxLongInt Then
FileEnd:=FileSize(F)
Else
FileEnd :=DEnd;
End;
If ErrorCode<>0 Then Goto EndProcAndClose;
Seek(F,FileEnd-10);
BlockRead(F,CheckSig[1],10);
CheckSig[0]:=#10;
ErrorCode:=IOResult;
If (ErrorCode<>0) Or (CheckSig<>Signature) Then
Begin
ErrorCode:=701; {Not a PPD File}
Goto EndProcAndClose;
End;
Seek(F,FileEnd-17);
BlockRead(F,CheckSig[1],7);
ErrorCode:=IOResult;
If ErrorCode<>0 Then
Begin
ErrorCode:=702; {Not a PPD File}
Goto EndProcAndClose;
End;
Compress:=Ord(CheckSig[4]);
If (Ord(CheckSig[5]) And InEXEFlag) = 0 Then
InEXE:=False
Else
InEXE:=True;
If (Ord(CheckSig[5]) And NameFlag) = 0 Then
HaveNames:=False
Else
HaveNames:=True;
If InEXE Then
Move(CheckSig[1],DataSize,2)
Else
Begin
If HaveNames Then
DirEntry:=12+2+4+2+1
Else
DirEntry:=2+4+2+1;
End;
VerHi:=Ord(CheckSig[6]);
VerLo:=Ord(CheckSig[7]);
If VerHi>CurVerHi Then
ErrorCode:=602
Else
If VerLo>CurVerLo Then
ErrorCode:=601;
If Compress<>C_None Then
ErrorCode:=650+Compress;
Goto EndProc;
EndProcAndClose:
Close(F);
EndProc:
If Not InEXE And (ErrorCode=0) Then ErrorCode:=ReadDir;
OpenDatabase:=ErrorCode;
End;
Function DBaseFile.CloseDatabase:Word;
Begin
PrevDirs.Destroy;
Init;
Close(F);
CloseDatabase:=IOResult;
End;
Function DBaseFile.CrossIntoDatabase(Name:String;Number:Word):Word;
{Never Add or Delete From a Directory Database}
Var
WhichOne :Word;
DirData :DBaseDir;
OldDir :Data;
Begin
DirData.Name:=Name;
DirData.Number:=Number;
WhichOne:=FindDir(DirData);
If WhichOne=0 Then
CrossIntoDatabase:=603
Else
Begin
DestroyDirs;
If PrevDirs.Full Then
CrossIntoDatabase:=604
Else
Begin
OldDir.FileStart:=FileStart;
OldDir.FileEnd :=FileEnd;
PrevDirs.Push(OldDir);
CrossIntoDatabase:=OpenDatabase('',DirData.Offset,DirData.Offset+DirData.Size);
End;
End;
End;
Function DBaseFile.CrossOutOfDatabase:Word;
Var
OldDir :Data;
Begin
If PrevDirs.Empty Then
CrossOutOfDatabase:=605
Else
Begin
DestroyDirs;
PrevDirs.Pop(OldDir);
CrossOutOfDatabase:=OpenDatabase('',OldDir.FileStart,OldDir.FileEnd);
End;
End;
Function DBaseFile.BlockInsert(Offset:LongInt;Data:Pointer;Size:Word):Word;
Label
EndProc,
EndProcAndClose;
Var
ErrorCode :Word;
G :File;
P :Pointer;
AmountLeft:LongInt;
CopyAmnt,
BlockSize :Word;
Begin
ErrorCode:=0;
Seek(F,0);
ErrorCode:=IOResult;
If ErrorCode<>0 Then Goto EndProc;
Assign(G,TempFile);
Rewrite(G,1);
ErrorCode:=IOResult;
If ErrorCode<>0 Then Goto EndProc;
Seek(G,FileSize(F)+Size-1);
BlockWrite(G,G,1); {Make the File the Correct Size}
ErrorCode:=IOResult;
If ErrorCode>0 Then Goto EndProcAndClose;
If MaxAvail>=64512 Then
BlockSize:=64512
Else
BlockSize:=MaxAvail;
GetMem(P,BlockSize);
Seek(F,0);
Seek(G,0);
AmountLeft:=Offset;
While (AmountLeft<>0) And (ErrorCode=0) do
Begin
If AmountLeft<BlockSize Then
CopyAmnt:=AmountLeft
Else
CopyAmnt:=BlockSize;
BlockRead (F,P^,CopyAmnt);
BlockWrite(G,P^,CopyAmnt);
ErrorCode:=IOResult;
Dec(AmountLeft,CopyAmnt);
End;
BlockWrite(G,Data^,Size);
If ErrorCode=0 Then ErrorCode:=IOResult;
AmountLeft:=FileSize(F)-Offset;
While (AmountLeft<>0) And (ErrorCode=0) do
Begin
If AmountLeft<BlockSize Then
CopyAmnt:=AmountLeft
Else
CopyAmnt:=BlockSize;
BlockRead (F,P^,CopyAmnt);
BlockWrite(G,P^,CopyAmnt);
ErrorCode:=IOResult;
Dec(AmountLeft,CopyAmnt);
End;
FreeMem(P,BlockSize);
If ErrorCode<>0 Then Goto EndProcAndClose;
Close(F);
Close(G);
Assign(F,FileName);
Erase(F);
Assign(G,TempFile);
Rename(G,FileName);
Assign(F,FileName);
Reset(F,1);
ErrorCode:=IOResult;
Goto EndProc;
EndProcAndClose:
Close(G);
Assign(G,TempFile);
Erase(G);
EndProc:
BlockInsert:=ErrorCode;
End;
Function DBaseFile.BlockOverwrite(Offset:LongInt;Data:Pointer;Size:Word):Word;
{Uses ABSOLUTE File Adress}
Label
EndProc;
Var
ErrorCode :Word;
Begin
ErrorCode:=0;
Seek(F,Offset);
ErrorCode:=IOResult;
If ErrorCode<>0 Then Goto EndProc;
BlockWrite(F,Data^,Size);
ErrorCode:=IOResult;
EndProc:
BlockOverwrite:=ErrorCode;
End;
Function DBaseFile.BlockDelete(Offset:LongInt;Size:Word):Word;
Label
EndProc,
EndProcAndClose;
Var
ErrorCode :Word;
G :File;
P :Pointer;
AmountLeft:LongInt;
CopyAmnt,
BlockSize :Word;
Begin
ErrorCode:=0;
Seek(F,0);
ErrorCode:=IOResult;
If ErrorCode<>0 Then Goto EndProc;
Assign(G,TempFile);
Rewrite(G,1);
ErrorCode:=IOResult;
If ErrorCode<>0 Then Goto EndProc;
Seek(G,FileSize(F)-Size-1);
BlockWrite(G,G,1); {Make the File the Correct Size}
ErrorCode:=IOResult;
If ErrorCode>0 Then Goto EndProcAndClose;
If MaxAvail>=64512 Then
BlockSize:=64512
Else
BlockSize:=MaxAvail;
GetMem(P,BlockSize);
Seek(F,0);
Seek(G,0);
AmountLeft:=Offset;
While (AmountLeft<>0) And (ErrorCode=0) do
Begin
If AmountLeft<BlockSize Then
CopyAmnt:=AmountLeft
Else
CopyAmnt:=BlockSize;
BlockRead (F,P^,CopyAmnt);
BlockWrite(G,P^,CopyAmnt);
ErrorCode:=IOResult;
Dec(AmountLeft,CopyAmnt);
End;
Seek(F,FilePos(F)+Size);
AmountLeft:=FileSize(F)-Offset-Size;
While (AmountLeft<>0) And (ErrorCode=0) do
Begin
If AmountLeft<BlockSize Then
CopyAmnt:=AmountLeft
Else
CopyAmnt:=BlockSize;
BlockRead (F,P^,CopyAmnt);
BlockWrite(G,P^,CopyAmnt);
ErrorCode:=IOResult;
Dec(AmountLeft,CopyAmnt);
End;
FreeMem(P,BlockSize);
If ErrorCode<>0 Then Goto EndProcAndClose;
Close(F);
Close(G);
Assign(F,FileName);
Erase(F);
Assign(G,TempFile);
Rename(G,FileName);
Assign(F,FileName);
Reset(F,1);
ErrorCode:=IOResult;
Goto EndProc;
EndProcAndClose:
Close(G);
Assign(G,TempFile);
Erase(G);
EndProc:
BlockDelete:=ErrorCode;
End;
Function DBaseFile.ReadDir:Word;
Var
X,
NewTotal :Word;
Data :DBaseDir;
Begin
DestroyDirs;
Seek(F,FileEnd-17);
BlockRead(F,NewTotal,2);
Seek(F,FileEnd-17-DirEntry*NewTotal);
For X:=1 to NewTotal do
Begin
If HaveNames Then
Begin
BlockRead(F,Data.Name[1],12);
Data.Name[0]:=#12;
UnPadVar(Data.Name,Data.Name);
End
Else
Data.Name:='';
BlockRead(F,Data.Number,9);
AppendDir(Data);
End;
ReadDir:=IOResult;
End;
Function DBaseFile.WriteDir:Word;
Var
NewName :String[12];
ErrorCode,
OldTotal :Word;
Begin
Seek(F,FileEnd-17);
BlockRead(F,OldTotal,2);
ErrorCode:=IOResult;
If ErrorCode=0 Then
Begin
If OldTotal<Dir.Total Then
ErrorCode:=BlockInsert(FileEnd-17,Ptr(0,0),(Dir.Total-OldTotal)*DirEntry)
{Insert any old data to make up file size}
Else
ErrorCode:=BlockDelete(FileEnd-17-(OldTotal-Dir.Total)*DirEntry,
(OldTotal-Dir.Total)*DirEntry);
Seek(F,FileEnd-17-DirEntry*OldTotal);
ErrorCode:=IOResult;
End;
If ErrorCode=0 Then
Begin
Dir.Data:=Dir.Root;
While (Dir.Data<>NIL) And (ErrorCode=0) do
Begin
If HaveNames Then
Begin
FormatVar(Dir.Data^.Name,NewName,12,LeftText);
BlockWrite(F,NewName[1],12);
End;
BlockWrite(F,Dir.Data^.Number,9);
Dir.Data:=Dir.Data^.Next;
End;
If ErrorCode=0 Then ErrorCode:=WriteHeader;
Inc(FileEnd,(LongInt(Dir.Total)-OldTotal)*DirEntry);
AdjustStackAfter(MaxLongInt,(LongInt(Dir.Total)-OldTotal)*DirEntry);
End;
WriteDir:=ErrorCode;
End;
Function DBaseFile.NewData(Name:String;Number:Word;Data:Pointer;Size:Word):Word;
Var
ErrorCode:Word;
DirData :DBaseDir;
Begin
DirData.Name :=Name;
DirData.Number:=Number;
DirData.Offset:=FileEnd-17-DirEntry*(Dir.Total);
DirData.Size :=Size;
DirData.Attr :=0;
AppendDir(DirData);
ErrorCode:=BlockInsert(FileStart+DirData.Offset,Data,Size);
If ErrorCode=0 Then
Begin
Inc(FileEnd,Size);
AdjustStackAfter(FileStart+DirData.Offset,Size);
ErrorCode:=WriteDir;
End;
NewData:=ErrorCode;
End;
Function DBaseFile.ModData(Name:String;Number:Word;Data:Pointer):Word;
Var
WhichOne,
ErrorCode:Word;
DirData :DBaseDir;
Begin
ErrorCode:=0;
DirData.Name :=Name;
DirData.Number:=Number;
WhichOne:=FindDir(DirData);
If WhichOne=0 Then ErrorCode:=603;
If ErrorCode=0 Then
ErrorCode:=BlockOverwrite(FileStart+DirData.Offset,Data,DirData.Size);
ModData:=ErrorCode;
End;
Function DBaseFile.GetData(Name:String;Number:Word;Data:Pointer):Word;
Var
WhichOne,
ErrorCode :Word;
DirData :DBaseDir;
Begin
ErrorCode:=0;
DirData.Name :=Name;
DirData.Number:=Number;
WhichOne:=FindDir(DirData);
If WhichOne=0 Then ErrorCode:=603;
If ErrorCode=0 Then
Begin
Seek(F,DirData.Offset);
BlockRead(F,Data^,DirData.Size);
ErrorCode:=IOResult;
End;
GetData:=ErrorCode;
End;
Function DBaseFile.DelData(Name:String;Number:Word):Word;
Var
WhichOne,
ErrorCode :Word;
DirData :DBaseDir;
Begin
ErrorCode:=0;
DirData.Name :=Name;
DirData.Number:=Number;
WhichOne:=FindDir(DirData);
If WhichOne=0 Then ErrorCode:=603;
If ErrorCode=0 Then
Begin
ErrorCode:=BlockDelete(FileStart+DirData.Offset,DirData.Size);
DelDir(WhichOne);
End;
If ErrorCode=0 Then
Begin
AdjustDirsAfter(DirData.Offset,-DirData.Size); {Don't add FileStart}
Dec(FileEnd,DirData.Size);
AdjustStackAfter(FileStart+DirData.Offset,-DirData.Size);
ErrorCode:=WriteDir;
End;
DelData:=ErrorCode;
End;
Function DBaseFile.NewDataFile(Name:String;Number:Word;FName:String):Word;
Label
EndProc,
EndProcAndClose;
Var
G :File;
ErrorCode:Word;
Data :Pointer;
Size :Word;
Begin
Assign(G,FName);
Reset(G,1);
ErrorCode:=IOResult;
If ErrorCode<>0 Then Goto EndProc;
Size:=FileSize(G);
If (Size>65500) Then
Begin
ErrorCode:=703;
Goto EndProcAndClose;
End;
If (MaxAvail<5192) Or (MaxAvail-5192<Size) Then
Begin
ErrorCode:=203;
Goto EndProcAndClose;
End;
GetMem(Data,Size);
BlockRead(G,Data^,Size);
ErrorCode:=NewData(Name,Number,Data,Size);
FreeMem(Data,Size);
EndProcAndClose:
Close(G);
EndProc:
NewDataFile:=ErrorCode;
End;
Function DBaseFile.ModDataFile(Name:String;Number:Word;FName:String):Word;
Label
EndProc,
EndProcAndClose;
Var
G :File;
WhichOne,
ErrorCode:Word;
Data :Pointer;
DirData :DBaseDir;
Size :Word;
Begin
ErrorCode:=0;
DirData.Name :=Name;
DirData.Number:=Number;
WhichOne:=FindDir(DirData);
If WhichOne=0 Then
Begin
ErrorCode:=603;
Goto EndProc;
End;
Assign(G,FName);
Reset(G,1);
ErrorCode:=IOResult;
If ErrorCode<>0 Then Goto EndProc;
Size:=FileSize(G);
If (Size>65500) Then
Begin
ErrorCode:=703;
Goto EndProcAndClose;
End;
If (Size<>DirData.Size) Then
Begin
ErrorCode:=606;
Goto EndProcAndClose;
End;
If (MaxAvail<5192) Or (MaxAvail-5192<Size) Then
Begin
ErrorCode:=203;
Goto EndProcAndClose;
End;
GetMem(Data,Size);
BlockRead(G,Data^,Size);
ErrorCode:=ModData(Name,Number,Data);
FreeMem(Data,Size);
EndProcAndClose:
Close(G);
EndProc:
ModDataFile:=ErrorCode;
End;
Function DBaseFile.GetDataFile(Name:String;Number:Word;FName:String):Word;
Label
EndProc,
EndProcAndFree;
Var
G :File;
DirData :DBaseDir;
Data :Pointer;
WhichOne,
ErrorCode :Word;
Begin
ErrorCode:=0;
DirData.Name :=Name;
DirData.Number:=Number;
WhichOne:=FindDir(DirData);
If WhichOne=0 Then
Begin
ErrorCode:=603;
Goto EndProc;
End;
If (DirData.Size>65500) Then
Begin
ErrorCode:=703;
Goto EndProc;
End;
If (MaxAvail<5192) Or (MaxAvail-5192<DirData.Size) Then
Begin
ErrorCode:=203;
Goto EndProc;
End;
GetMem(Data,DirData.Size);
ErrorCode:=GetData(Name,Number,Data);
If ErrorCode=0 Then
Begin
Assign(G,FName);
Rewrite(G,1);
ErrorCode:=IOResult;
If ErrorCode>0 Then Goto EndProcAndFree;
BlockWrite(G,Data^,DirData.Size);
Close(G);
ErrorCode:=IOResult;
End;
EndProcAndFree:
FreeMem(Data,DirData.Size);
EndProc:
GetDataFile:=ErrorCode;
End;
Function DBaseFile.ModEXE(Offset:LongInt;Data:Pointer;Size:Word):Word;
Begin
Seek(F,FileEnd-17-DataSize+Offset);
BlockWrite(F,Data^,Size);
ModEXE:=IOResult;
End;
Function DBaseFile.GetEXE(Offset:LongInt;Data:Pointer;Size:Word):Word;
Begin
Seek(F,FileEnd-17-DataSize+Offset);
BlockRead(F,Data^,Size);
GetEXE:=IOResult;
End;
Function DatabaseErrorMsg(ErrorNumber:Word):String;
Var
Temp:String;
Begin
If (ErrorNumber>650) And (ErrorNumber<700) Then
Str(ErrorNumber-650,Temp)
Else
Str(ErrorNumber,Temp);
Temp:=' '+Temp;
Case ErrorNumber Of
0 :DatabaseErrorMsg:='No Error';
1..500:DatabaseErrorMsg:='Runtime Error'+Temp;
601 :DatabaseErrorMsg:='Low-Version-Number Too High';
602 :DatabaseErrorMsg:='High-Version-Number Too High';
603 :DatabaseErrorMsg:='Item Requested Not Found in Database';
604 :DatabaseErrorMsg:='Unable To Access Sub Database (Out of Directory Stack)';
605 :DatabaseErrorMsg:='Already At Highest Level (Already In Parent Database)';
606 :DatabaseErrorMsg:='Data Size Mismatch';
651..
699 :DatabaseErrorMsg:='Compression System'+Temp+' Used. Decompress File';
701 :DatabaseErrorMsg:='Bad Database Signature (Not a Database File)';
702 :DatabaseErrorMsg:='Unable to Read Database Signature (Not a Database File)';
703 :DatabaseErrorMsg:='Cannot Have Segments Larger Than 64kb';
End;
End;
End.
{
╔══════════════════════════════════════════════════════════════╗
║ Pure Power Software ║
╟──────────────────────────────────────────────────────────────╢
║ ║
║ This software is copyright by Michael Gallias. ║
║ ║
╚══════════════════════════════════════════════════════════════╝
}